\ Excel Interface
\ Tom Dixon
\ 8/28/2008


also FCOM

\ *! Excel
\ *T Excel Interface Library

\ *P This library contains a number of words to exchange data with
\ ** Excel.

1 5 typelib {00020813-0000-0000-C000-000000000046}
\ Excel 2003 type library

\ COM interfaces used
_Application comiface App
Workbooks    comiface wbooks
_Workbook    comiface wbook
_WorkSheet   comiface wsheet

variable xlRange

create xlbuf 512 allot


: disp? ( vt -- ) VT_DISPATCH <> err_NotDispatch ?throw ;

: Excel-close ( -- )
\ *G Closes the Excel Interface and de-allocates all objects.
   wbook @ if wbook displate" Close" drop then
   App    Quit drop
   xlRange freeref
   wsheet freeref
   wbook  freeref
   wbooks freeref
   App    freeref ;

: Excel-init ( -- )
\ *G Initializes Excel and establishes interface.  Excel is initialized
\ ** in a separate process.
   App _Application CLSCTX_SERVER 0 Application fCoCreateInstance
   Abort" Unable to Start Excel Server!" ;

: ->wbooks ( -- )
   wbooks @ 0= if wbooks App GetWorkbooks
     abort" Unable to get workbooks!" then ;

: ->ActiveWbook ( -- )
   wbook @ 0= if wbook App GetActiveWorkbook
     abort" Unable to get Workbook!" then ;

: ->ActiveSheet ( -- )
   wsheet @ 0= if wsheet App GetActiveSheet
     abort" Unable to get Worksheet!" then ;

: >range ( x y -- )
   xlRange freeref ->ActiveSheet
   swap VT_INT >vt VT_INT >vt
   wsheet displate" GetCells" abort" Unable to get cells!"
   retvt@ disp? xlRange ! ;

: Visible! ( f -- )
\ *G Sets the visibility of Excel.  Calling this word with 1 will make
\ ** Excel visible, 0 will hide it (default behavior).
   0 App PutVisible drop ;

: Excel-new ( -- )
\ *G Creates a new workbook in Excel
   wbook 0 0 xlWBATWorksheet 0 VT_INT ->wbooks
   wbooks Add abort" Unable to open worksheet!" ;

: Excel-Open ( str len -- )
\ *G Opens an Excel file
   >unicode drop >r
   wbook 0 14 0 do 0 0 0 VT_NULL loop r> ->wbooks wbooks Open
   abort" Unable to open Workbook!" ;

: Excel-Save ( -- )
\ *G Saves the current Excel file.
   ->ActiveWbook 0 wbook Save abort" Unable to Save!" ;

: Excel-SaveAs ( str len -- )
\ *G Saves the current Excel file under a given file name.
   >unicode drop >r ->ActiveWBook
   0 5 0 do 0 0 0 VT_NULL loop
   xlNoChange 5 0 do 0 0 0 VT_NULL loop
   0 r> 0 VT_BSTR wbook SaveAs abort" Unable to Save!" ;

: >XL ( x y -- )
   >range xlRange displate" GetValue"
   abort" Unable to get Cell Value!" ;

: XLf@ ( x y -- float )
\ *G Fetches the floating point value in cell (x,y) on the current worksheet.
\ ** If the value is not a floating point, an exception will be thrown.
   >XL retvt@ case
     VT_R4   of drop RetVT 8 + sf@ endof
     VT_R8   of 2drop RetVT 8 + df@ endof
     VT_DATE of 2drop RetVT 8 + df@ endof
     true abort" Not a floating point number!"
   endcase ;

: XL@ ( x y -- n )
\ *G Fetches an integer value in cell (x,y) on the current worksheet.
\ ** If the value is not a number, an exception will be thrown.
   XLf@ f>s ;

: XLstr@ ( x y -- str len )
\ *G Fetches the value in cell (x,y) as a string.
   >range xlRange displate" GetText"
   abort" Unable to get String!"
   retvt@ VT_BSTR <> abort" Not a string value!"
   zunicount >ascii ;

: XLval! ( -- )
   xlRange displate" PutValue"
   abort" Unable to set Value!" ;

: XLstr! ( str len x y -- )
\ *G Stores a string to cell (x,y) in the current worksheet.  The string
\ ** may be text, but can also be an Excel formula.
   2swap >unicode xlbuf uniplace
   >range xlbuf cell+ VT_BSTR >vt xlVal! ;

: XL! ( n x y -- )
\ *G Stores an integer to cell (x,y) in the current worksheet.
   >range VT_INT >vt XLval! ;

: XLf! ( float x y -- )
\ *G Stores a floating point number to cell (x,y) in the current worksheet.
   >range pad df! pad 2@ VT_R8 >vt XLval! ;
   
: XLver ( -- str len ) 
   xlbuf 256 App COM _Application GetVersion 
   abort" Unable to get Version"
   xlbuf @ zunicount >ascii ;

free-lasttypelib
previous

\ ======
\ *> ###
\ ======




